Visual Basic Toolbox/Visual Basic Toolbox (P.I.E.)(1996).ISO/pgm_ing/tagenv/tagenv.bas

BASIC Source File | 1992-09-24 | 7KB | 249 lines

'   TAGENV.BAS

'   REQUIRES:
'             STRTOK.BAS


'   TagString subsystem:
'
'   This set of routines provides support for tagged string fields
'   in a VB Form or Control Tag property.
'
'   The Tag property, under this support, consists of a string
'   of keyword=value pairs, delimited by semicolons;  for instance,
'   the following might be a tag string:
'
'   formname=myForm;myname="Thomas A. Dacon";graphsize=large
'
'   You delete a string from a tagged string field by setting it
'   to a null string, just like the SET command in DOS.
'
'   Keywords and contents fields are stored in mixed case, as supplied,
'   but searches for keywords are case-insensitive.

'   The API:
'
'   SetFormTagString <form>,    key$, contents$
'   GetFormTagString <form>,    key$, contents$
'
'   SetCtlTagString  <control>, key$, contents$
'   GetCtlTagString  <control>, key$, contents$
'


    Const FALSE = 0, TRUE = Not FALSE

Sub SetFormTagString (f As Form, key As String, contents As String)
'
'   Insert, replace, or delete a key=contents field
'   in a Form's Tag property.
'
    Dim theTagString As String

    theTagString = f.Tag
    SetTagSubstring theTagString, key, contents
    f.Tag = theTagString

End Sub

Sub GetFormTagString (f As Form, key As String, contents As String)
'
'   Get the current value of a key=contents field
'   in a Form's Tag property.  A null string is
'   returned if the key is not found.
'
    GetTagSubstring (f.Tag), key, contents

End Sub

Sub SetCtlTagString (c As Control, key As String, contents As String)
'
'   Insert, replace, or delete a key=contents field
'   in a Control's Tag property.
'
    Dim theTagString As String

    theTagString = c.Tag
    SetTagSubstring theTagString, key, contents
    c.Tag = theTagString

End Sub

Sub GetCtlTagString (c As Control, key As String, contents As String)
'
'   Get the current value of a key=contents field
'   in a Control's Tag property.  A null string is
'   returned if the key is not found.
'
    GetTagSubstring (c.Tag), key, contents

End Sub

Sub SetTagSubstring (theTagString As String, key As String, contents As String)
'
'   Internal routine to insert, replace, or delete
'   a key=contents field in a string variable.
'
    Dim tagStringAccumulator As String
    Dim thisString As String
    Dim subString As String
    Dim theKey As String
    Dim substringToAdd As String

    tagStringAccumulator = ""

    If theTagString <> "" Then
        thisString = theTagString
        foundIt = FALSE
        Do
            subString = StrTok$(thisString, ";")
            thisString = ""              'for subsequent strtok calls
            If subString <> "" Then
                If Not foundIt Then
                    theKey = ExtractKey$(subString)
                    If theKey <> key Then
                        substringToAdd = subString
                        GoSub AddSubstring
                    Else    'this deletes if new contents = ""
                        foundIt = TRUE
                        If contents <> "" Then
                            substringToAdd = key + "=" + contents
                            GoSub AddSubstring
                        End If
                    End If
                Else
                    substringToAdd = subString
                    GoSub AddSubstring
                End If
            End If
        Loop Until subString = ""

        '   If we didn't find the key, we need to add the
        '   substring as a new one (providing there's content).

        If Not foundIt Then
            If contents <> "" Then
                substringToAdd = key + "=" + contents
                GoSub AddSubstring
            End If
        End If

    Else                                         'no current contents in tag string
        If contents <> "" Then                   'if user supplied contents,
            substringToAdd = key + "=" + contents
            GoSub AddSubstring
        End If
    End If

    '   Return the resulting tag string.

    theTagString = tagStringAccumulator
    Exit Sub


'   Add a substring to the end of the tag string accumulator.

AddSubstring:
    If tagStringAccumulator <> "" Then
        tagStringAccumulator = tagStringAccumulator + ";"
    End If
    tagStringAccumulator = tagStringAccumulator + substringToAdd
    Return

End Sub

Sub GetTagSubstring (theTagString As String, key As String, contents As String)
'
'   Internal routine to retrieve the contents of a key=contents
'   field in a string variable.
'
    Dim thisString As String
    Dim subString As String

    contents = ""   'in case we don't find the key

    If theTagString <> "" Then
        thisString = theTagString
        Do
            subString = StrTok$(thisString, ";")
            thisString = ""
            If subString <> "" Then
                If UCase$(ExtractKey$(subString)) = UCase$(key) Then
                    contents = ExtractKeyValue$(subString)
                    Exit Do
                End If
            End If
        Loop Until subString = ""
    End If

End Sub

Function ExtractKey$ (theSubString As String)
'
'   Returns the keyword portion of a
'   keyword=value string "kkk=vvvvv"
'
    Dim i As Integer
    Dim theKey As String

    i = InStr(theSubString, "=")
    If i <> 0 Then
        theKey = Left$(theSubString, i - 1)
    Else
        theKey = ""
    End If

    ExtractKey$ = theKey

End Function

Function ExtractKeyValue$ (theSubString As String)
'
'   Returns the value portion of a
'   keyword=value string "kkk=vvvvv"
'

    Dim i As Integer
    Dim theContents As String

    i = InStr(theSubString, "=")
    If i <> 0 Then
        theContents = Mid$(theSubString, i + 1)
    Else
        theContents = ""
    End If

    ExtractKeyValue$ = theContents

End Function

Function ParseKeywordValue (text As String, keyword As String, keyvalue As String) As Integer
'
'   Given a text string of the form:
'           keyword = value
'       or  keyword = "value"
'   parses the keyword and value into the output arguments,
'   stripping leading and trailing blanks, and removing the
'   optional double quotes from the value field.
'
'   Returns Boolean("=" character present, following a non-blank field)
'
    Dim eqPos As Integer
    Dim quotes As String * 1

    eqPos = InStr(text, "=")
    If eqPos > 0 Then
        keyword = LTrim$(RTrim$(Left$(text, eqPos - 1)))
        keyvalue = LTrim$(RTrim$(Mid$(text, eqPos + 1)))
        quotes = Chr$(34)
        If Left$(keyvalue, 1) = quotes And Right$(keyvalue, 1) = quotes Then
            keyvalue = Mid$(keyvalue, 2, Len(keyvalue) - 2)
        End If
    End If

    ParseKeywordValue = (eqPos > 0) And (keyword <> "")

End Function